home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / apel / tinyrich.el.z / tinyrich.el
Encoding:
Text File  |  1998-05-21  |  4.0 KB  |  167 lines
  1. ;;;
  2. ;;; $Id: tinyrich.el,v 5.0 1995/09/20 14:45:56 morioka Exp $
  3. ;;;
  4. ;;;          by MORIOKA Tomohiko  <morioka@jaist.ac.jp>
  5. ;;; modified by YAMATE Keiichirou <ics9118@sem1.info.osaka-cu.ac.jp>
  6. ;;;
  7.  
  8. (defvar mime-viewer/face-list-for-text/enriched
  9.   (cond ((and (>= emacs-major-version 19) window-system)
  10.      '(bold italic fixed underline)
  11.      )
  12.     ((and (boundp 'NEMACS) NEMACS)
  13.      '("bold" "italic" "underline")
  14.      )))
  15.  
  16. (defun enriched-decode (beg end)
  17.   (interactive "*r")
  18.   (save-excursion
  19.     (save-restriction
  20.       (narrow-to-region beg end)
  21.       (goto-char beg)
  22.       (while (re-search-forward "[ \t]*\\(\n+\\)[ \t]*" nil t)
  23.     (let ((str (buffer-substring (match-beginning 1)
  24.                      (match-end 1))))
  25.       (if (string= str "\n")
  26.           (replace-match " ")
  27.         (replace-match (substring str 1))
  28.         )))
  29.       (goto-char beg)
  30.       (let (cmd sym str (fb (point)) fe b e)
  31.     (while (re-search-forward "<\\(<\\|[^<>\n\r \t]+>\\)" nil t)
  32.       (setq b (match-beginning 0))
  33.       (setq cmd (buffer-substring b (match-end 0)))
  34.       (if (string= cmd "<<")
  35.           (replace-match "<")
  36.         (replace-match "")
  37.         (setq cmd (downcase (substring cmd 1 (- (length cmd) 1))))
  38.         )
  39.       (setq sym (intern cmd))
  40.       (cond ((eq sym 'param)
  41.          (setq b (point))
  42.          (save-excursion
  43.            (save-restriction
  44.              (if (search-forward "</param>" nil t)
  45.              (progn
  46.                (replace-match "")
  47.                (setq e (point))
  48.                )
  49.                (setq e end)
  50.                )))
  51.          (delete-region b e)
  52.          )
  53.         ((memq sym mime-viewer/face-list-for-text/enriched)
  54.          (setq b (point))
  55.          (save-excursion
  56.            (save-restriction
  57.              (if (re-search-forward (concat "</" cmd ">") nil t)
  58.              (progn
  59.                (replace-match "")
  60.                (setq e (point))
  61.                )
  62.                (setq e end)
  63.                )))
  64.          (tm:set-face-region b e sym)
  65.          )))
  66.     (goto-char (point-max))
  67.     (if (not (eq (preceding-char) ?\n))
  68.         (insert "\n")
  69.       )
  70.     ))))
  71.  
  72.  
  73. ;;; @ text/richtext <-> text/enriched converter
  74. ;;;
  75.  
  76. (defun richtext-to-enriched-region (beg end)
  77.   "Convert the region of text/richtext style to text/enriched style."
  78.   (save-excursion
  79.     (save-restriction
  80.       (narrow-to-region beg end)
  81.       (goto-char (point-min))
  82.       (let (b e i)
  83.     (while (re-search-forward "[ \t]*<comment>" nil t)
  84.       (setq b (match-beginning 0))
  85.       (delete-region b
  86.              (if (re-search-forward "</comment>[ \t]*" nil t)
  87.                  (match-end 0)
  88.                (point-max)
  89.                ))
  90.       )
  91.     (goto-char (point-min))
  92.     (while (re-search-forward "\n\n+" nil t)
  93.       (replace-match "\n")
  94.       )
  95.     (goto-char (point-min))
  96.     (while (re-search-forward "[ \t\n]*<nl>[ \t\n]*" nil t)
  97.       (setq b (match-beginning 0))
  98.       (setq e (match-end 0))
  99.       (setq i 1)
  100.       (while (looking-at "[ \t\n]*<nl>[ \t\n]*")
  101.         (setq e (match-end 0))
  102.         (setq i (1+ i))
  103.         (goto-char e)
  104.         )
  105.       (delete-region b e)
  106.       (while (>= i 0)
  107.         (insert "\n")
  108.         (setq i (1- i))
  109.         ))
  110.     (goto-char (point-min))
  111.     (while (search-forward "<lt>" nil t)
  112.       (replace-match "<<")
  113.       )
  114.     ))))
  115.  
  116. (defun enriched-to-richtext-region (beg end)
  117.   "Convert the region of text/enriched style to text/richtext style."
  118.   (save-excursion
  119.     (save-restriction
  120.       (goto-char beg)
  121.       (and (search-forward "text/enriched")
  122.        (replace-match "text/richtext"))
  123.       (search-forward "\n\n")
  124.       (narrow-to-region (match-end 0) end)
  125.       (let (str n)
  126.     (goto-char (point-min))
  127.     (while (re-search-forward "\n\n+" nil t)
  128.       (setq str (buffer-substring (match-beginning 0)
  129.                       (match-end 0)))
  130.       (setq n (1- (length str)))
  131.       (setq str "")
  132.       (while (> n 0)
  133.         (setq str (concat str "<nl>\n"))
  134.         (setq n (1- n))
  135.         )
  136.       (replace-match str)
  137.       )
  138.     (goto-char (point-min))
  139.     (while (search-forward "<<" nil t)
  140.       (replace-match "<lt>")
  141.       )
  142.     ))))
  143.  
  144.  
  145. ;;; @ encoder and decoder
  146. ;;;
  147.  
  148. (defun richtext-decode (beg end)
  149.   (save-restriction
  150.     (narrow-to-region beg end)
  151.     (richtext-to-enriched-region beg (point-max))
  152.     (enriched-decode beg (point-max))
  153.     ))
  154.  
  155. ;; (defun richtext-encode (beg end)
  156. ;;   (save-restriction
  157. ;;     (narrow-to-region beg end)
  158. ;;     (enriched-encode beg (point-max))
  159. ;;     (enriched-to-richtext-region beg (point-max))
  160. ;;     ))
  161.  
  162.  
  163. ;;; @ end
  164. ;;;
  165.  
  166. (provide 'tinyrich)
  167.